MacWorld 1999 July

home *** CD-ROM | disk | FTP | other *** search

/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / PPC source / pnuc3 < prev next >

Wrap

Text File | 1999-01-10 | 20KB | 796 lines

\ =========================== \ APPLEEVENTS \ =========================== : AEHANDLER ( ^AE ^AEReply RefCon -- ) \ Put at the start of an AppleEvent handler proc. Pops the parms into \ the appropriate locations. ; : GOTPARMS? ( -- rc ) \ This can be called at the end of a handler, to check if we got all \ the parameters. ; : ?RTNAEPMISSED ( rc -- rc' ) \ This can be called after calling GotParms? to convert the return code \ from that word to the appropriate return code to return to the caller \ of the handler. If GotParms? returns false, that means we missed \ a parm, so we return -1715. If GotParms? returned anything non-zero, \ that means we got all the parms, so we return zero. IF 0 ELSE -1715 THEN ; \ ======================== \ ERROR HANDLING \ ======================== (* This is unfortunately a bit complicated. The basic mechanism is the standard CATCH and THROW. Apart from THROW, there are three words which signal an error - ABORT, ABORT" and our Mops error dump word DIE. The standard says that if CATCH and THROW are implemented, ABORT throws a -1, and ABORT" throws a -2. This allows a throw handler to catch these and override the default error action. If no throw handler is installed, the default action occurs. For this default action, we define DFLT_ABORT and DFLT_ERR (I assume I didn't want to call it dflt-abort" since it doesn't take an inline string - that was stored by ABORT".) We follow the same philosophy with DIE. The error code passed to DIE is simply THROWn (note we don't use any negative error code for a non-ANSI Mops error), which allows a throw handler to intercept it. And we define DFLT_DIE to be executed if there's no throw handler, which does our normal Mops error dump to the Mops window. *) forward QUIT forward (.stk) forward .objOrRA forward tstr 0 value origCDP \ set to the "normal" CDP if we're \ temporarily in the execution buffer : TypeErrNum ( err# -- ) instld? ?EXIT cr ." Error # " dup . space tstr ; (* SAVE_ERR ( addr len ^ed -- ) saves all the info needed for an error dump, for later use by the default error handling routine which may be called after the stacks have been reset. This way, THROW can be called without our having to know if a non-default error routine is installed or not. ( addr len ) specifies an error text string. We may pass ( err# -1 ), in which case err# is a Mops error number, whose text can be typed via TSTR. For ABORT, which has no error string, we pass ( 0 0 ). Our normal error word is DIE, which calls SAVE_ERR, then calls ThrowWithInfo, the alternative to THROW. *) : svStk { start finish ^ed \ cnt -- ^ed' } finish start - 2 >> -> cnt \ ## assumes 4-byte cells cnt maxDump min -> cnt cnt ^ed ! 1cell ++> ^ed cnt FOR start @ ^ed ! 1cell ++> start 1cell ++> ^ed NEXT ^ed ; : SAVE_ERR { addr len \ ^ed -- } ^errDump -> ^ed len ^ed ! 1cell ++> ^ed addr ^ed ! 1cell ++> ^ed \ save the two parms (^base) ^ed ! 1cell ++> ^ed \ save ptr to current obj (-1 if none) SP SP0 ^ed svStk -> ^ed \ save data stack RP 20 + \ don't want to display the Rstack \ cells with our error-handling calls \ and saved regs RP0 ^ed svStk drop \ save return stack ; \ .ERR displays the error info saved by SAVE_ERR. The value .stkLimit \ gives a maximum of stack cells dumped -- this can be used to keep \ info from scrolling off the screen. big# value .stk_limit false value dumping? : .ERR { \ addr len ^obj \ ^ed -- } dumping? IF cr EXIT THEN ^errDump -> ^ed ^ed @ -> len 1cell ++> ^ed ^ed @ -> addr 1cell ++> ^ed setFwind \ Redirected to abort word in installed applicns, so \ we don't try to type to the Mops window, which may \ well not exist. true -> dumping? 5 beep cr len 0> IF addr len type space \ there's an error string ELSE len 0< IF \ no error string - "addr" is \ really an err number addr 10 u> \ err# 1-10 don't have messages - we \ can use them for special things IF addr typeErrNum THEN THEN THEN cr src-start src-len type cr \ type error line >in @ 1- spaces & ^ emit cr \ and error position marker ^ed @ 1cell ++> ^ed -> ^obj ^obj -1 <> IF ." Current object: " ^obj .objOrRA cr THEN ^ed @ cells -> len 1cell ++> ^ed \ .stk_limit 2dup > if nip else drop then cells -> len ." Stack:" ^ed len over + false (.stk) len ++> ^ed ^ed @ cells -> len 1cell ++> ^ed \ .stk_limit min cells -> len ." Return stack:" ^ed len over + true (.stk) big# -> .stk_limit false -> dumping? ; forward setup_cg : dflt_abort setup_cg \ a bit drastic, but if the error is an index \ out of range on one of our register arrays, \ we'll just keep hitting the error! origCDP IF origCDP -> CDP THEN abortVec SP0 4+ SP! RP0 RP! FSP0 16 + FSP! decimal 0 #TIB ! set_source +curs 0 -> cstate false -> local? 0 -> mod_seg# QUIT ; : dflt_abq err_info_valid? IF 3 -> .stk_limit .err ELSE typeErrNum THEN dflt_abort ; forward DFLT_DIE : (ddie) setFwind 0 -> (err#) \ Clear error indicator from AppleEvents dflt_abq ; \ Display error info and abort :f dflt_die (ddie) ;f (* CATCH ( xt -- n ) EXECUTEs the xt. If the executed word does a THROW, n is the error code passed to THROW. If it doesn't do a THROW, n is zero. If it does a THROW, control doesn't return to CATCH, but to whoever called CATCH. See the Standard for a full description. We have to use assembly for setting this up, since we're manipulating registers. *) 0 value THROW_HANDLER \ holds the addr of the current throw handler \ frame, or zero if none. : frameErr ." Return stack clobbered!" dflt_abort ; : no_throw_handler ( n -- ) \ branched to from (THROW) if there's no \ handler. Takes the default action. errorVec \ set to error word in installed apps, so \ we can bail out without Mops development \ environment error handling dup -1 = IF dflt_abort THEN \ -1: do default ABORT dup -2 = IF dflt_abq THEN \ -2: do default ABORT" dflt_die ; :ppc_code CATCH r0 mflr, r0 -4 rRP stw, \ save lr - our return addr r3 -16 rRP stwu, \ now save 1 cached stack cell (r3). r4 is \ xt for EXECUTE so we don't need to save it. \ Note rRP must stay 8-byte aligned ' saves 2+ bl, rRP -48 addi, \ now all our GPR locals (& keep rRP aligned) ' fsaves 2+ bl, rRP -88 addi, \ and all our FPR locals r0 $ 789A li, r0 -16 rRP stwu, \ create frame header and store marker rSP 4 rRP stw, \ save SP at offs 4 r0 ' throw_handler 2+ @abs6 dicaddr lwz, r0 8 rRP stw, \ and previous handler addr at offs 8 rRP ' throw_handler 2+ @abs6 dicaddr stw, \ and store RP (frame ptr) as new handler addr ' execute 2+ bl, \ execute the passed-in xt. Note \ this call only returns if THROW \ isn't done. r0 0 rRP lwz, \ check our special marker is still r0 $ 789A cmpli, \ on top of rtn stk eq if, \ yep, all OK r0 8 rRP lwz, \ get prev throw_handler from offs 8 r0 ' throw_handler 2+ @abs6 dicaddr stw, \ restore previous throw_handler rRP rRP 168 addi, \ delete rest of frame - all regs OK already r0 -4 rRP lwz, \ restore lr r0 mtlr, \ r3 -4 rSP stwu, \ we have 2 cached cells - push one off \ r3 r4 mr, r4 r0 0 addi, \ and return zero on top (means no error) blr, then, ' frameErr 2+ b, \ rtn stk marker not there - call frameErr ;ppc_code (* THROW has two variants. ThrowWithInfo is used by our normal error word DIE, and also by ABORT", which both save the error info (including a message string) before doing a normal throw. This variant signals that the saved error info is valid. Our default error handler DFLT_DIE, which is called if no throw handler has been installed, tests this flag to decide whether to call .ERR to display the info. If THROW is called directly from code, it flags the error info invalid, which prevents DFLT_DIE from calling .ERR and displaying spurious info. *) :ppc_code (THROW) r4 0 cmpli, \ is THROW code nonzero ne if, \ yes - we do the throw: rX ' throw_handler 2+ @abs6 dicaddr lwz, \ restore previous throw_handler rX 0 cmpli, \ is there a throw handler? ne if, r0 0 rX lwz, \ check our special marker is still r0 $ 789A cmpli, \ on top of rtn stk eq if, \ yep, all OK rRP rX mr, \ set RP to point to handler frame \ Now we restore everything from the frame: rSP 4 rRP lwz, \ rSP from offs 4 r0 8 rRP lwz, r0 ' throw_handler 2+ @abs6 dicaddr stw, \ and previous throw_handler from offs 8 rRP 104 addi, ' frestores 2+ bl, \ restore FPR locals rRP 48 addi, ' restores 2+ bl, \ and GPR locals rRP 16 addi, \ delete rest of frame r0 -4 rRP lwz, \ restore lr r0 mtlr, r3 -16 rRP lwz, \ and cached stack cell (r3) blr, \ and return to CATCH caller then, ' frameErr 2+ b, \ rtn stk marker not there - call frameErr then, ' no_throw_handler 2+ b, \ no throw handler: take default action then, r4 r3 mr, \ throw code zero - no error - just drop r3 0 rSP lwz, \ the zero and return. rSP rSP 4 addi, blr, ;ppc_code :f THROW false -> err_info_valid? (throw) ;f : THROW_WITH_INFO true -> err_info_valid? (throw) ; : ABORT 0 0 save_err -1 throw ; (* ABORT" is immediate, so we've already defined it before CROSS in qCond. It gets the string parameter, then EVALUATEs do_abq which we define here. What we end up doing is in effect this: : ABORT" postpone " rot NIF 2drop EXIT THEN save_err -2 throw_with_info ; immediate *) : do_abq rot NIF 2drop EXIT THEN save_err -2 throw_with_info ; 0 value svErrNum :f DIE dup -> svErrNum -1 save_err \ -1 indicates to save_err that \ this is an err# svErrNum throw_with_info ;f (* **** \ THROW test: : could-fail key dup & A = if $ 1234 throw then ; : doit could-fail nip nip nip ; : throwtest dbgr 1 2 3 ['] doit catch \ if there's no throw, the 1 2 3 will be dropped, and we'll get \ the typed key. If throw is executed, we should get the 1 2 3 \ and the error number $ 1234 on the stack. dbgr dup IF ." Error was thrown" cr .s ELSE drop ." The char was " emit cr THEN ; **** *) : ?COMP state ?EXIT -14 die ; : ?STACK depth dup 0< IF -4 die THEN \ "stack underflow" stack_size >= IF -5 die THEN \ "stack overflow" fdepth dup 0< IF -45 die THEN \ "floating-point stack underflow" fstack_size >= IF -44 die THEN \ "floating-point stack overflow" ; : ?EXEC state 0EXIT 77 die ; \ "Execution state only" : ?PAIRS = ?EXIT -22 die ; \ "Control structure mismatch" : ?DEFN = ?EXIT 78 die ; \ "Unbalanced definition" (* (excep) is branched to from our exception handler in zObjInit. We don't really know which regs held the top stack cells when the exception occurred, so we just take as stab that it was r3 and r4. The exception handler leaves the excep code in r5. So we set up (excep) with 3 named parms, which will be r3, r4 and r5. Here's Apple's defn of the exception codes: kUnknownException = 0 kIllegalInstructionException = 1 kTrapException = 2 kAccessException = 3 kUnmappedMemoryException = 4 kExcludedMemoryException = 5 kReadOnlyMemoryException = 6 kUnresolvablePageFaultException = 7 kPrivilegeViolationException = 8 kTraceException = 9 kInstructionBreakpointException = 10 kDataBreakpointException = 11 kIntegerException = 12 kFloatingPointException = 13 kStackOverflowException = 14 kTerminationException = 15 *) : (excep) { x y ex# -- } x y ex# 210 + die \ we just assign all the message numbers appropriately \ so we don't have to do any other testing on the \ number. ; \ ==================== ADDRESSING ===================== \ 16bits? ( n signed? -- n b ) \ returns true if n will fit in 16 bits (signed or unsigned as requested). : 16BITS? \ ( n signed? -- n b ) IF -32768 32767 within? ELSE dup 16 >> 0= THEN ; \ seg#>gpr# finds if the passed-in seg# corresponds to a currently \ set up base register. If so, it returns the reg#. If not, it \ returns zero. : seg#>gpr# \ ( seg# -- gpr# ) CASE[ 8 ]=> mainCode_reg EXIT [ 9 ]=> mainData_reg EXIT DEFAULT=> ]CASE ( seg# ) \ here we don't use case[ since the test values aren't constant. \ dup $ 11 = if dbgr then dup mod_seg# = IF drop modCode_reg EXIT THEN dup mod_seg# 1+ = IF drop modData_reg EXIT THEN dup comp_seg# = IF drop modCode_reg EXIT THEN comp_seg# 1+ = IF modData_reg EXIT THEN 0 \ failed - return zero ; \ B&D takes the passed-in address and converts it to gpr# and displacement. \ We also store the appropriate segment # in seg#_to_use, in case we're \ generating a relocatable addr. 0 value seg#_to_use : s&d>b&d { seg# displ \ displ' gpr# -- gpr# displ' } 0 -> seg#_to_use seg# seg#>gpr# -> gpr# \ will be zero if we didn't get a reg gpr# mainCode_reg = IF displ code_start + nuc_code_start - half_displ_range - -> displ' displ' true 16bits? nip NIF \ displ' doesn't fit in 16 bits, but we might have \ a const data pointer which we can use... CD_gpr# IF \ if we've set it, we use it, since this will \ just about always give us a displ which fits \ in 16 bits CD_gpr# -> gpr# displ code_start + CD_gpr_loc - -> displ' THEN THEN gpr# displ' EXIT THEN gpr# mainData_reg = IF \ If the address is down in the code generator \ area and out of range from mainData_reg, we \ might be able to use RTOC instead, which of \ course points to the start of the data area. mainData_reg displ data_start + nuc_data_start - half_displ_range - \ true 16bits? ?EXIT \ \ displ true 16bits? nip \ IF 2drop RTOC_reg displ THEN EXIT THEN gpr# IF seg# -> seg#_to_use gpr# displ half_displ_range - ELSE \ theAddr wasn't in range of any reg - return two zeros 0 0 THEN ; : (B&D) ( addr -- gpr# displ ) addr>S&D s&d>b&d ; : B&D { theAddr -- reg# displ } theAddr (b&d) over NIF cr theAddr .h ." is an out-of-range addr!" 1 die THEN ; \ @B&D fetches a relocatable addr and returns the "real" base \ gpr# and displacement. This is used for going from the code \ area to the data area, for values etc. : @B&D { addr \ relocAddr seg# displ gpr# -- gpr# displ' } addr @ -> relocAddr relocAddr $ ffffff and -> displ relocAddr 24 >> -> seg# seg# displ s&d>b&d over NIF 70 die THEN \ seg# didn't refer to a loaded reg, or was just \ garbage - "not a reloc addr" (* seg# seg#>gpr# -> gpr# gpr# mainCode_reg = IF mainCode_reg displ code_start + nuc_code_start - half_displ_range - EXIT THEN gpr# mainData_reg = IF mainData_reg displ data_start + nuc_data_start - half_displ_range - EXIT THEN gpr# IF gpr# displ half_displ_range - \ machine instrns use a signed displ, so we \ point base regs 32k above the seg start ELSE \ seg# didn't refer to a loaded reg, or was just garbage 70 die \ " not a reloc addr" THEN *) ; : RELOC! { theAddr dest -- } \ theAddr $ 1000 u< if dbgr then theAddr addr>S&D $ ffffff and swap 24 << or dest ! ; \ ================================ \ CONVERSION BETWEEN RELATIVE AND \ ABSOLUTE ADDRESSES \ ================================ \ Note: @abs is already defined in Setup, since we needed it earlier. : DISPLACE ( addr -- addr' ) inline{ dup @ dup if + else nip then} ; : WDISPLACE ( addr -- addr' ) inline{ dup w@x dup if + else nip then} ; : DISPL! { src dst -- } \ Stores the source address as a relative address at the destination. src dst - dst ! ; : WDISPL! { src dst -- } \ Stores the source address as a short relative address at the destination \ (it is relative to the destination). src dst - dst w! ; : reloc, DP reloc! 4 ++> DP ; : relocCode, CDP reloc! 4 ++> CDP ; : displCode, CDP displ! 4 ++> CDP ; \ ===================================== \ DICTIONARY OPERATIONS \ ===================================== forward defined? \ needed by FORGET. Defined in pnuc4. (* Patches_done is called on the 68k after any new instructions have been stored, or patches have been done, and before the instructions are executed. It flushes the instruction cache if necessary. On some PPC models there's also a separate icache and dcache, so we have to do the same sort of thing. The appropriate sequence of ops must be executed with interrupts off, so Apple helpfully provides a call to do it -- MakeDataExecutable. *) :f FIX_CACHES { addr len -- } len 0EXIT addr len %_MakeDataExecutable ;f \ : ALLOT ( n -- ) ++> DP ; : RESERVE ( n -- ) DP over 0 fill ++> DP ; : , ( n -- ) DP ! 4 ++> DP ; : W, ( n -- ) DP w! 2 ++> DP ; : C, ( n -- ) DP c! 1 ++> DP ; : N, ( addr len -- ) >r DP r@ cmove r> allot ; : DISPL, ( src -- ) DP - , ; : code, CDP ! 4 ++> CDP ; : codeW, CDP w! 2 ++> CDP ; : codeC, CDP c! 1 ++> CDP ; : codeN, ( addr len -- ) tuck CDP swap cmove ++> CDP ; : ALIGN4 DP 4 reserve \ just to ensure pad bytes are zero 3 + $ fffffffc and -> DP ; : ALIGN8 DP 8 reserve 7 + $ fffffff8 and -> DP ; : ALIGN align4 ; : ALIGN-DP align4 ; : #ALIGN inline{ 3+ -4 and} ; \ a synonym for #align4 (in pnuc1) \ - on the PPC our default alignment is \ 4 byte : ALIGNED inline{ 3+ -4 and} ; \ ANSI - same as #align4 on PPC : #ALIGN2 inline{ 1+ -2 and} ; \ #align4 is in pnuc1, since we need it early : #ALIGN8 inline{ 7 + $ fffffff8 and} ; : #ALIGN16 inline{ 15 + $ fffffff0 and} ; : #align_2**n ( value n -- value' ) 1 swap << 1- dup not down + and ; : #OFF-ALIGN \ ( n -- n' ) Aligns to the 2-byte boundary between \ adjacent 4-byte boundaries. 5 + $ fffffffc and 2- ; : code_allot ++> CDP ; : code_reserve CDP over erase ++> CDP ; : code_align CDP 4 erase CDP #align4 -> CDP ; \ FORGET isn't really adequate on the PPC, since it can't handle the \ data area or syscall_chain etc. But I'll keep it for backward \ compatibility, and it can be called by MARKER anyway to do the \ part of the job that it can. \ Trim ( lfa -- new_latest ) is called by (forget). : trim { lfa \ cxt nxt link new_lfa -- new_latest } 0 -> new_lfa #threads FOR context i 2 << + dup -> cxt \ addr of this context entry displace BEGIN dup lfa u>= WHILE displace REPEAT \ new context value for this thread dup new_lfa umax -> new_lfa cxt displ! NEXT new_lfa l>name \ new link field -> new name field, which \ will become the new LATEST ; : (FORGET) { lfa -- } lfa fence u< IF -15 die THEN \ "invalid FORGET" lfa trim -> latest \ now we reset CDP to lfa. First we call fix_caches on the range \ we're wiping out, since it doesn't exist any more, and we're \ a bit paranoid. lfa \ where we're wiping out from CDP lfa - \ # bytes we're wiping out fix_caches lfa -> CDP \ reset CDP to new spot ; : FORGET defined? ?notfound \ i.e. tick - but we can't define that yet since \ we still need the 68k tick. It's in qpCond. >link (forget) ; \ ============= Module-related words =================== (* There are a few module-related words which we use in the class code. Holdmod is forward defined, and resolved in zModules. Of course it should never need to be executed before zModules is loaded! unholdMod and ?unholdMod don't release the module as they do on the 68k - once a module is loaded it stays put. So all these words have to do here is clear heldMod. *) forward holdMod : unholdMod 0 -> heldMod ; : ?unholdMod 0 -> heldMod ; : ?>classInMod ( ^class -- ^class' ) \ 0 -> seg#_accessed \ leave zero if we don't go into a module dup 2- w@ \ class handler code $ BC2D = IF holdMod \ if class_in_mod_h, replaces ^class with the \ xt of the class in the mod, and holds it. THEN ; endload